home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / tspa3155.zip / TSUNTG.TST < prev    next >
Text File  |  1992-11-08  |  10KB  |  366 lines
  1. {$M 16384,0,655360}
  2.  
  3. (* This is a test program for the TSUNTG.TPU unit
  4.    Updated 26-Nov-89, 6-Dec-89, 14-Jun-90, 22-Jul-90, 1-Aug-90,
  5.            8-Aug-90, 27-Oct-91, 13-Jun-92, 19-Oct-92, 8-Nov-92 *)
  6.  
  7. uses Dos,
  8.      TSUNTB,  (* to have access to number base conversion *)
  9.      TSUNTH,  (* to have access to keyboad type *)
  10.      TSUNTG;
  11.  
  12. procedure LOGO;
  13. begin
  14.   writeln;
  15.   writeln ('TSUNTG unit test by Prof. Timo Salmi');
  16.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  17. {$IFDEF VER40}
  18.   writeln ('TP version 4.0');
  19. {$ENDIF}
  20. {$IFDEF VER50}
  21.   writeln ('TP version 5.0');
  22. {$ENDIF}
  23. {$IFDEF VER55}
  24.   writeln ('TP version 5.5');
  25. {$ENDIF}
  26. {$IFDEF VER60}
  27.   writeln ('TP version 6.0');
  28. {$ENDIF}
  29.   writeln;
  30. end;
  31.  
  32. (* Number of diskette drives *)
  33. procedure TEST1;
  34. begin
  35.   writeln ('Number of diskette drives on this system is ', DRIVESFN);
  36. end; (* test1 *)
  37.  
  38. (* Number of disk devices *)
  39. procedure TEST2;
  40. begin
  41. {$IFDEF VER50}
  42.   if swap(DosVersion) < $0300 then
  43.     begin writeln ('Not MsDos 3.+'); exit; end;
  44. {$ENDIF}
  45.   writeln ('Number of disks on this system is ', DSKCNTFN);
  46. end;  (* test2 *)
  47.  
  48. (* Number of diskette drives *)
  49. procedure TEST3;
  50. begin
  51.   writeln ('The first diskette drive is ', FDRIVEFN);
  52. end; (* test3 *)
  53.  
  54. (* Is a media present in the drive *)
  55. procedure TEST4;
  56. const drive = 'B';
  57. begin
  58.   If INDRIVFN (drive) then
  59.     writeln ('Disk present in drive ', drive)
  60.   else
  61.     writeln ('Disk not present in drive ', drive);
  62. end;  (* test4 *)
  63.  
  64. (* Cursor location test *)
  65. procedure TEST5;
  66. var x , y : byte;
  67. begin
  68.   GOATXY (10, 20);
  69.   write ('▓The block is at 10,20 .');
  70.   x := WHEREXFN - 1; y := WHEREYFN;
  71.   write (' and the point at ', x:0, ',', y:0);
  72. end;  (* test5 *)
  73.  
  74. (* Reverse the colors of an area *)
  75. procedure TEST6;
  76. begin
  77.   REVAREA (2, 2, 79, 24);
  78.   GOATXY (1, 22);
  79. end;  (* test6 *)
  80.  
  81. (* Redirection of writes *)
  82. procedure TEST7;
  83. begin
  84.   writeln ('If you get runtime error 160, first test for printer readiness');
  85.   writeln ('TSUNTC has the relevant routines');
  86.   writeln;
  87.   USEPRN;
  88.   writeln ('This goes to the printer');
  89.   writeln ('As does this');
  90.   USECON;
  91.   write   ('This goes on the screen');
  92. end;  (* test7 *)
  93.  
  94. (* Test of the timed inkey function *)
  95. procedure TEST8;
  96. var key : char;
  97.     timeout : boolean;
  98. begin
  99.   repeat
  100.     key := INKEYFN (3.0, timeout);
  101.     if not timeout then write (key)
  102.       else begin writeln; writeln ('Timeout',#7); end;
  103.   until key = #27;
  104. end;  (* test8 *)
  105.  
  106. (* Try warmboot *)
  107. procedure TEST9;
  108. var ch : char;
  109. begin
  110.   write ('Press Y if you really want to test a warm reboot, any other key to cancel ');
  111.   repeat
  112.     if KEYPREFN then
  113.       begin
  114.         ch := READKEFN;
  115.         case ch of
  116.           #3       : exit;
  117.           #27      : exit;
  118.           #0       : begin
  119.                        if KEYPREFN then
  120.                          begin
  121.                            ch := READKEFN;
  122.                            exit;
  123.                          end;
  124.                      end;
  125.           'Y', 'y' : WARMBOOT;
  126.           #0..#255 : exit;
  127.           else     ;
  128.         end; {case}
  129.       end; {if}
  130.   until false;
  131. end;  (* test9 *)
  132.  
  133. (* Test whether a media is a fixed disk *)
  134. procedure TEST10;
  135. var drive : string;
  136. begin
  137.   write ('Enter drive letter? '); readln (drive);
  138.   case Length (drive) of
  139.     0  : drive := '0';
  140.     else drive := UpCase(drive[1]);
  141.   end;
  142.   if FIXEDFN (drive[1]) then
  143.      writeln ('Media ', drive , ' is a fixed disk')
  144.    else
  145.      writeln ('Media ', drive , ' is not a fixed disk');
  146. end;  (* test10 *)
  147.  
  148. (* Detect special keys, and normal keyboard scancodes. Note that depending
  149.    on the keyboard some of the tests below can be mutually exclusive.
  150.    CTLFN excludes detecting RTCTRLFN, LFCTRLFN, and SYSRQFN. ALTFN excludes
  151.    FLATLFN. *)
  152. procedure TEST11;
  153. var ch : char;
  154. begin
  155.   writeln ('Esc to exit');
  156.   repeat
  157.     if LFSHFTFN then write ('LfShift ');
  158.     if RTSHFTFN then write ('RtShift ');
  159.     {}
  160.     if ISENHAFN then
  161.        begin
  162.          if LFCTRLFN then write ('LfCtrl ');
  163.          if RTCTRLFN then write ('RtCtrl ');
  164.        end
  165.      else
  166.        if CTRLFN then write ('Ctrl ');
  167.     {}
  168.     if ISENHAFN then
  169.        if LFALTFN  then write ('LfAlt ')
  170.          else                               (* Notice the else else trick *)
  171.       else
  172.          if ALTFN    then write ('Alt ');
  173.     {}
  174.     if RTALTFN  then write ('RtAlt ');
  175.     if SYSRQFN  then write ('SysRq ');
  176.     if KEYPREFN then
  177.       begin
  178.         ch := READKEFN;
  179.         case ch of
  180.           #0  : begin
  181.                   write (byte(ch), ' ');    (* ord(ch) is ok, too *)
  182.                   ch := READKEFN;           (* byte(ch) is an just an *)
  183.                   write (byte(ch), ' ');    (* example of typecasting *)
  184.                 end;
  185.           #27 : exit;
  186.           else write (byte(ch), ' ');
  187.         end; {case}
  188.       end; {if}
  189.   until false;
  190. end;  (* test11 *)
  191.  
  192. (* Test reading enhanced keyboard keys. Notice the trick to get the
  193.    low and the high parts of a Turbo Pascal word *)
  194. procedure TEST12;
  195. var scancode : word;
  196.     key      : array [1..2] of byte absolute scancode;
  197. begin
  198.   repeat
  199.     scancode := RDENKEFN;
  200.     {}
  201.     {... show the first part of the scancode ...}
  202.     write (key[1], ' ');
  203.     {}
  204.     {... enhanced keys have also a second part in the scancode ...}
  205.     case key[1] of
  206.       0, 224 : write (key[2], ' ');
  207.     end;
  208.   until (key[1] = 27)                 (* escape with esc *)
  209.          or (scancode = 0);           (* not an enhanced keyboard *)
  210. end;  (* test12 *)
  211.  
  212. (* Test whether ANSI.SYS or a comparable driver has been loaded *)
  213. procedure TEST13;
  214. begin
  215.   if ISANSIFN then
  216.     writeln ('ANSI.SYS or a comparable screen driver has been installed')
  217.   else
  218.     begin
  219.       writeln;
  220.       writeln ('ANSI.SYS or a comparable screen driver has not been installed');
  221.     end;
  222. end;  (* test13 *)
  223.  
  224. (* Display the ascii value and the scancode of the key pressed *)
  225. procedure TEST14;
  226. var scanCode : byte;
  227.     charCode : byte;
  228.     s        : string;
  229. begin
  230.   writeln ('Press Esc to end this folly');
  231.   writeln;
  232.   repeat
  233.     GETSCAN (scanCode, charCode);
  234.     case charCode of
  235.       0..31, 129..255 : begin
  236.                           Str(charCode, s);
  237.                           s := 'asc(' + s + ')';
  238.                         end;
  239.       else s := chr(charCode)
  240.     end; {case}
  241.     writeln (s, ' scancode = ', scancode:3);
  242.   until scancode = 1;
  243. end;  (* test14 *)
  244.  
  245. (* Display the ascii value and the scancode of the key pressed for
  246.    the enhanced keyboard with GETESCAN. To test the presence of an
  247.    enhanced keyboard use ISENHAFN from the TSUNTH unit *)
  248. procedure TEST15;
  249. var scanCode : byte;
  250.     charCode : byte;
  251.     s        : string;
  252. begin
  253.   writeln ('Press Esc to end this folly');
  254.   writeln;
  255.   repeat
  256.     GETESCAN (scanCode, charCode);
  257.     case charCode of
  258.       0..31, 129..255 : begin
  259.                           Str(charCode, s);
  260.                           s := 'asc(' + s + ')';
  261.                         end;
  262.       else s := chr(charCode)
  263.     end; {case}
  264.     writeln (s, ' scancode = ', scancode:3);
  265.   until scancode = 1;
  266. end;  (* test15 *)
  267.  
  268. (* Test the disk status *)
  269. procedure TEST16;
  270. const drive = 'A';
  271. var status : integer;
  272. begin
  273.   status := FLOPSTFN (drive);
  274.   if status = -1 then
  275.     begin
  276.       writeln ('Invalid drive, must be A or B');
  277.       exit;
  278.     end; {if}
  279.   writeln ('Disk status for ', drive, ': $', BHEXFN(status));
  280.   case status of
  281.     $00 : writeln ('Disk present');
  282.     $02 : writeln ('Address mark not found (Disk unformatted)');
  283.     $40 : writeln ('Seek failure (Disk not present?)');
  284.     $80 : writeln ('Disk timed out (Disk not present in drive)');
  285.   end;
  286. end;  (* test16 *)
  287.  
  288. (* Test whether a drive is a substituted drive *)
  289. procedure TEST17;
  290. const drive = 'R';
  291. var isubst : boolean;
  292. begin
  293.   if (100*Lo(DosVersion) + Hi(DosVersion)) < 310 then
  294.     begin
  295.       writeln ('The MsDos version must be at least 3.1');
  296.       exit;
  297.     end;
  298.   isubst := ISUBSTFN (drive);
  299.   writeln ('Drive ', drive, ' is a substituted drive is ', isubst);
  300. end;  (* test17 *)
  301.  
  302. (* What kind of a disk is in the drive *)
  303. procedure TEST18;
  304. const drive = 'B';
  305. var mediaID : byte;
  306. begin
  307.   mediaID := MEDIAFN (drive);
  308.   write ('Media currently in drive ', drive, ': is ');
  309.   case mediaID of
  310.     $00 : writeln ('Error');
  311.     $F0 : writeln ('Floppy of 1.44Mb');
  312.     $F8 : writeln ('Fixed disk');
  313.     $F9 : writeln ('Floppy of 1.2Mb');
  314.     $FA : writeln ('Floppy of 720Kb');
  315.     $FD : writeln ('Floppy of 360Kb');
  316.     $FF : writeln ('Floppy of 320Kb');
  317.     else  writeln ('something else');
  318.   end; {case}
  319. end;  (* test18 *)
  320.  
  321. (* Get the currently active floppy drive on one drive systems *)
  322. procedure TEST19;
  323. var active : char;
  324. begin
  325.   active := ACTDRVFN;
  326.   write ('The currently active floppy drive is ');
  327.   case active of
  328.     '0' : writeln ('Error ');
  329.     'A' : writeln ('A:');
  330.     'B' : writeln ('B:');
  331.     '2' : writeln ('not relevant (Two or more drives)');
  332.   end;
  333. end;  (* test19 *)
  334.  
  335. (* Main program
  336.    If you just want a particular test, comment the others away, just as
  337.    I have done.
  338.    If you want pauses, put readln where appropriate *)
  339. begin
  340.   LOGO;
  341.   {
  342.   TEST1;
  343.   TEST2;
  344.   TEST3;
  345.   TEST4;
  346.   TEST5;
  347.   TEST6;
  348.   TEST7;
  349.   TEST8;
  350.   TEST9;
  351.   TEST10;
  352.   TEST11;
  353.   TEST12;
  354.   TEST13;
  355.   TEST14;
  356.   TEST15;
  357.   TEST16;
  358.   }
  359.   TEST16;
  360.   TEST17;
  361.   TEST18;
  362.   TEST19;
  363.   {}
  364.   write ('Press <-'' '); readln;
  365. end.  (* tsuntg.tst *)
  366.